;;; -*- Mode:Lisp;Package:INTERNET;Base:10 -*-
;;; This is SYS: IP; HOSTSNIC

;;; The format for entries is:
;;;
;;; NET : NET-ADDR : NETNAME :
;;; GATEWAY : ADDR, ADDR : NAME : CPUTYPE : OPSYS : PROTOCOLS :
;;; HOST : ADDR, ALTERNATE-ADDR (if any): HOSTNAME,NICKNAME : CPUTYPE :
;;;   OPSYS : PROTOCOLS :
;;;
;;; Where:
;;;  ADDR = internet address in decimal, e.g., 26.0.0.73
;;;  CPUTYPE = machine type (PDP-11/70, VAX-11/780, FOONLY-F3, C/30, etc.)
;;;  OPSYS = operating system (UNIX, TOPS20, TENEX, ITS, etc.)
;;;  PROTOCOLS = transport/service (TCP/TELNET,TCP/FTP, etc.)
;;;  : (colon) = field delimiter
;;;  :: (2 colons) = null field
;;;
;;; See RFC810 for more details.

(DEFUN NMAPCAR (&FUNCTIONAL FUNCTION LIST)
  "Destructive map over the LIST with FUNCTION"
  (DO ((TAIL LIST (CDR TAIL)))
      ((NULL TAIL))
    (SETF (CAR TAIL) (FUNCALL FUNCTION (CAR TAIL)))))

(DEFUN KEY-INTERN (STRING)
  ;; These are checks for parser BD.  Better safe than sorry
  (IF (ZEROP (STRING-LENGTH STRING))
      (FERROR () "Attempt to intern null string while parsing host table"))
  (IF (STRING-SEARCH-SET '(#\Space #\Newline #\: #\\) STRING)
      (FERROR () "Attempt to intern funny string ~S while parsing host table"))
  (INTERN (STRING-UPCASE STRING) PKG-KEYWORD-PACKAGE))

(DEFVAR *IDX-VAR*)
(DEFVAR *BEGIN-VAR*)
(DEFVAR *LINE-VAR*)
(DEFVAR *TEMPORARY*)
(DEFVAR *FIELD-VAR*)

(DEFVAR *DEBUG-PARSER-MACROS* NIL "T causes expansion to include diagnostics")

(DEFMACRO PARSING-ALONG ((LINE-VAR FIELD-VAR) &BODY BODY)
  (LET ((IDX-VAR (GENTEMP "I"))
        (BEGIN-VAR (GENTEMP "B"))
        (TEMPORARY-VAR (GENTEMP "T")))
    `(COMPILER-LET ((*IDX-VAR* ',IDX-VAR)
                    (*BEGIN-VAR* ',BEGIN-VAR)
                    (*LINE-VAR* ',LINE-VAR)
                    (*FIELD-VAR* ',FIELD-VAR)
                    (*TEMPORARY* ',TEMPORARY-VAR))
       (LET ((,IDX-VAR -1) (,BEGIN-VAR) (,TEMPORARY-VAR))
         ,@BODY))))

(DEFMACRO PARSE-ACT (&BODY AFTER-COLON &AUX (TAG (GENSYM)))
  `(TAGBODY
       (SETQ ,*FIELD-VAR* NIL)
       ,TAG
       (SETQ ,*BEGIN-VAR* (+ ,*IDX-VAR* 1))
       (SETQ ,*IDX-VAR* (STRING-SEARCH-SET ",:" ,*LINE-VAR* ,*BEGIN-VAR*))
       (UNLESS (= ,*IDX-VAR* ,*BEGIN-VAR*)
         (SETQ ,*TEMPORARY* (STRING-TRIM " " (SUBSTRING ,*LINE-VAR* ,*BEGIN-VAR* ,*IDX-VAR*)))
         (COND ((NULL ,*FIELD-VAR*)
                (SETQ ,*FIELD-VAR* ,*TEMPORARY*))
               ((STRINGP ,*FIELD-VAR*)
                (SETQ ,*FIELD-VAR* (LIST ,*FIELD-VAR* ,*TEMPORARY*)))
               (T
                (SETQ ,*FIELD-VAR* (NCONC ,*FIELD-VAR* (NCONS ,*TEMPORARY*)))))
         ,(WHEN *DEBUG-PARSER-MACROS*
            `(FORMAT *TRACE-OUTPUT* "~&Field (~S) is now ~S" ',*FIELD-VAR* ,*FIELD-VAR*))
         (IF (CHAR= (AREF ,*LINE-VAR* ,*IDX-VAR*) #/,) (GO ,TAG)
           ,@AFTER-COLON))))

(DEFUN PARSE-NIC-PROTOCOL-SPEC (STRING &AUX (IDX (STRING-SEARCH-CHAR #// STRING)))
  (IF (NULL IDX) (KEY-INTERN STRING)
    (CONS (KEY-INTERN (STRING-RIGHT-TRIM " " (SUBSTRING STRING 0 IDX)))
          (KEY-INTERN (STRING-LEFT-TRIM " " (SUBSTRING STRING (1+ IDX)))))))

(DEFUN PARSE-NIC-MACHINE-LINE (LINE TYPE &AUX RESULT NAME FIELD)
  (PARSING-ALONG (LINE FIELD)
    (PARSE-ACT ; addresse(s)
      (PUSH (IF (CLI:LISTP FIELD) FIELD (LIST FIELD)) RESULT)
      (PUSH :ADDRESSES RESULT))
    (PARSE-ACT ; names(s)
      (COND ((STRINGP FIELD)
             (SETQ NAME FIELD)
             (SETQ FIELD (LIST FIELD)))
            ((CONSP FIELD)
             (SETQ NAME (FIRST FIELD))))
      (PUSH FIELD RESULT)
      (PUSH :HOST-NAMES RESULT))
    (PARSE-ACT ; cputype
      (PUSH (KEY-INTERN FIELD) RESULT)
      (PUSH :MACHINE-TYPE RESULT))
    (PARSE-ACT ; opsys
      (PUSH (KEY-INTERN FIELD) RESULT)
      (PUSH :SYSTEM-TYPE RESULT))
    (PARSE-ACT ; transport/services
      (IF (STRINGP FIELD)
          (PUSH (LIST (KEY-INTERN FIELD)) RESULT)
        (NMAPCAR #'PARSE-NIC-PROTOCOL-SPEC FIELD)
        (PUSH FIELD RESULT))
      (PUSH :PROTOCOLS RESULT)))
  (CONS TYPE (CONS NAME RESULT)))

(DEFUN (:PROPERTY :HOST NIC-PARSE-LINE) (LINE)
  (PARSE-NIC-MACHINE-LINE LINE :HOST))

(DEFUN (:PROPERTY :GATEWAY NIC-PARSE-LINE) (LINE)
  (PARSE-NIC-MACHINE-LINE LINE :GATEWAY))

(DEFUN (:PROPERTY :NET NIC-PARSE-LINE) (LINE &AUX RESULT FIELD)
  (PARSING-ALONG (LINE FIELD)
    (PARSE-ACT ; address
      (PUSH FIELD RESULT)
      (PUSH :ADDRESS RESULT))
    (PARSE-ACT ; name
      ))
  (CONS :NET (CONS FIELD RESULT)))

(DEFUN PARSE-NIC-LINE (LINE INCLUDE-OBJECTS &AUX COLON TYPE PARSER)
  (IF (OR (ZEROP (STRING-LENGTH LINE)) (CHAR= (AREF LINE 0) #/;))
      (VALUES NIL NIL)
    (SETQ TYPE (KEY-INTERN (STRING-TRIM
                             " " (SUBSTRING LINE 0
                                            (SETQ COLON (STRING-SEARCH-CHAR #/: LINE))))))
    (WHEN (MEMQ TYPE INCLUDE-OBJECTS)
      (SETQ PARSER (GET TYPE 'NIC-PARSE-LINE))
      (IF (NULL PARSER)
          (FERROR () "Unknown type ~S" TYPE)
        (VALUES T (FUNCALL PARSER (STRING-RIGHT-TRIM " " (SUBSTRING LINE (+ COLON 1)))))))))

(DEFVAR *INCLUDE-OBJECTS* :UNBOUND)
(DEFVAR *CURRENT-INPUT-STREAM* :UNBOUND)
(DEFVAR *CURRENT-INPUT-FILE-LIST* :UNBOUND)
(DEFVAR *NIC-STREAM* :UNBOUND)

(DEFUN NIC-ENTRY-STREAM-D-H (OP &OPTIONAL ARG1 &REST REST)
  (STREAM-DEFAULT-HANDLER *NIC-STREAM* OP ARG1 REST))

(DEFSELECT (NIC-ENTRY-STREAM NIC-ENTRY-STREAM-D-H)
  (:CLOSE (IGNORE)
    (AND *CURRENT-INPUT-STREAM* (SEND *CURRENT-INPUT-STREAM* :CLOSE)))
  (:ENTRY ()
    (IF (NOT (OR *CURRENT-INPUT-STREAM* *CURRENT-INPUT-FILE-LIST*))
        ()
      (UNLESS *CURRENT-INPUT-STREAM*
        (WHEN *CURRENT-INPUT-FILE-LIST*
          (SETQ *CURRENT-INPUT-STREAM* (OPEN (CAR *CURRENT-INPUT-FILE-LIST*)))
          (SETQ *CURRENT-INPUT-FILE-LIST* (CDR *CURRENT-INPUT-FILE-LIST*))))
      (DO (SOMETHING-HAPPENED RESULT LINE EOF)
          (())
        (MULTIPLE-VALUE (LINE EOF) (SEND *CURRENT-INPUT-STREAM* :LINE-IN))
        (WHEN EOF
          (SEND *CURRENT-INPUT-STREAM* :CLOSE)
          (SETQ *CURRENT-INPUT-STREAM* NIL))
        (UNLESS *CURRENT-INPUT-STREAM*
          (IF (NULL *CURRENT-INPUT-FILE-LIST*) (RETURN NIL)
            (SETQ *CURRENT-INPUT-STREAM* (OPEN (CAR *CURRENT-INPUT-FILE-LIST*)))
            (SETQ *CURRENT-INPUT-FILE-LIST* (CDR *CURRENT-INPUT-FILE-LIST*))))
        (MULTIPLE-VALUE (SOMETHING-HAPPENED RESULT) (PARSE-NIC-LINE LINE *INCLUDE-OBJECTS*))
        (IF SOMETHING-HAPPENED (RETURN RESULT)))))
  (:TRUENAMES ()
    (CLI:MAP 'LIST #'(LAMBDA (FILE) (SEND FILE :TRUENAME)) *CURRENT-INPUT-FILE-LIST*)))

(DEFUN MAKE-NIC-ENTRY-STREAM-CLOSURE ()
  (CLOSURE '(*CURRENT-INPUT-FILE-LIST* *CURRENT-INPUT-STREAM* *NIC-STREAM* *INCLUDE-OBJECTS*)
           'NIC-ENTRY-STREAM))

(DEFUN MAKE-NIC-ENTRY-STREAM-FROM-FILES (INPUT-FILES INCLUDE-OBJECTS)
  (LET ((*CURRENT-INPUT-FILE-LIST* (CLI:MAP 'LIST #'FS:PARSE-PATHNAME INPUT-FILES))
        (*INCLUDE-OBJECTS* INCLUDE-OBJECTS)
        (*CURRENT-INPUT-STREAM* NIL)
        (*NIC-STREAM* NIL))
    (SETQ *NIC-STREAM* (MAKE-NIC-ENTRY-STREAM-CLOSURE))))

(DEFUN MAKE-NIC-ENTRY-STREAM-FROM-STREAM (INPUT-STREAM INCLUDE-OBJECTS)
  (LET ((*CURRENT-INPUT-FILE-LIST* NIL)
        (*INCLUDE-OBJECTS* INCLUDE-OBJECTS)
        (*CURRENT-INPUT-STREAM* INPUT-STREAM)
        (*NIC-STREAM* NIL))
    (SETQ *NIC-STREAM* (MAKE-NIC-ENTRY-STREAM-CLOSURE))))
          (CLOSURE '(*CURRENT-INPUT-FILE-LIST* *CURRENT-INPUT-STREAM* *NIC-STREAM*)
                   'NIC-ENTRY-STREAM))))

(DEFUN GENERATE-LISP-INTERNET-TABLE
       (&KEY (INPUT-FILES (LIST (GET-SITE-OPTION :LOCAL-INTERNET-HOST-TABLE)))
             (OUTPUT-FILE "SYS: SITE; INTERNET LISP >")
             (INCLUDE-OBJECTS '(:HOST)))
  (WITH-OPEN-STREAM (NIC (MAKE-NIC-ENTRY-STREAM-FROM-FILES INPUT-FILES INCLUDE-OBJECTS))
    (WITH-OPEN-FILE (OUT OUTPUT-FILE :DIRECTION :OUTPUT)
      (PKG-BIND 'INTERNET
        (LET ((*PRINT-CASE* :UPCASE)
              (*PRINT-LEVEL* NIL) (*PRINT-LENGTH* NIL)
              (DEFINE-CONS (CONS 'NETI:DEFINE-THING NIL)))
        (FORMAT OUT "~
;;; -*- Mode:Lisp; Package:~A; Base: ~D -*-
;;; This was generated by a program; do NOT edit it.
;;; This is ~A.
;;; It was made by ~A on ~\DATIME\ from the following files:
;;; ~A~%"
                *PACKAGE* *PRINT-BASE* (SEND OUT :TRUENAME) USER-ID (SEND NIC :TRUENAMES))
      (DO ((ENTRY (SEND NIC :ENTRY) (SEND NIC :ENTRY)))
          ((NULL ENTRY))
        (SEND OUT :TYO #\Newline)
        (SETF (CDR DEFINE-CONS) ENTRY)
        (WRITE DEFINE-CONS :STREAM OUT)))))))
